Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/desktop/syscolor/syscolor.bas

BASIC Source File | 1994-07-31 | 27KB | 934 lines

Option Explicit

'   //*************************************************//
'   //*                                               *//
'   //*                SYSCOLOR.BAS                   *//
'   //*                [GB] 03/07/94                  *//
'   //*                                               *//
'   //*************************************************//

'   //This module contains functions for manipulating the windows
'   //system colours.
'   //Functions are labelled PRIVATE and PUBLIC //
'   //You should only use the functions labelled +++ PUBLIC +++


'   //******************* LIST OF PUBLIC FUNCTIONS ************************//

'   //** FUNCTION Hex2Long (HexString As String) As Long

'   //Example: ALongInt = Hex2Long("C0")
'   //Purpose:
'   //Converts a valid Hex$ into it's corresponding decimal value//
'   //* Note - Do NOT use this for converting RGB Hex strings *//

'   //*********************************************************************//

'   //** SUB EnumerateSchemes()

'   //Example: EnumerateSchemes
'   //Purpose:
'   //Fills the Global Dynamic Array SCHEME(1 to i_LastScheme) with
'   //the names of the User's Colour schemes in CONTROL.INI
'   //Could be used to fill a Menu Array for the user to select from..
'   //No Initialisation needed.
Global Scheme() As String
Global i_LastScheme As Integer

'   //*********************************************************************//

'   //** SUB WriteSysColoursToINI (SchemeString As String, INIPath As String)

'   //Example: WriteSysColoursToINI "Favorite", "C:\WINDOWS\COLOURS.INI"
'   //Purpose:
'   //Writes an entry in a private INI file that can be read by GetSysColoursFromINI
'   //Note - INIPath is the FULL path, including the filename
'   //Entries written to CONTROL.INI can be read by Windows 3.1 Control Panel
'   //No Initialisation required.

'   //*********************************************************************//

'   //** SUB GetSysColoursFromINI (SchemeString As String, INIPath As String)

'   //Example: GetSysColoursFromINI "Favorite", "C:\WINDOWS\COLOURS.INI"
'   //Purpose:
'   //Sets the User's system colours from a saved set in a private INI file
'   //Note - INIPath is the FULL path, including the filename
'   //Use WriteSysColoursToINI to write a private entry, or specify
'   //INIPath to be CONTROL.INI - both use the same format.

'   //*********************************************************************//

'   //** SUB SaveSysColours ()

'   //Example: SaveSysColours
'   //Purpose:
'   //This routine stores the User's System Colours//
'   //Call it to take a snapshot (to be restored by RestoreSysColours) //
'   //No Initialisation required.

'   //*********************************************************************//

'   //** SUB RestoreSysColours ()

'   //Example: RestoreSysColours
'   //Purpose:
'   //Restores system colours to that saved by SaveSysColours
'   //No Initialisation required.

'   //*********************************************************************//

'   //** SUB  SetColourSchemeFromControlPanel (SchemeString As String)

'   //Example: SetColourSchemeFromControlPanel "Wing Tips"
'   //Effect is not permanent//
'   //SchemeString could be got from the dynamic array Scheme()
'   //No Initialisation required.

'   //*********************************************************************//

'   //** SUB SetDefaultColourSchemeFromControlPanel ()

'   //Example: SetDefaultColourSchemeFromControlPanel
'   //This is the scheme that the user has set as their default
'   //Effect is not permanent. No initialisation needed//
'   //No Initialisation required.

'   //*********************************************************************//


'   //** SUB SetSysColour (Element As Integer, RGBValue As Long)

'   //Example1: SetSysColour COLOR_MENU, RGB(255,192,255)
'   //Example2: SetSysColour COLOR_MENU, QBColor(2)
'   //Example3: SetSysColour COLOR_BTNTEXT, 0

'   //Element is one of the COLOR_ constants below
'   //RGBValue can be RGB(x,y,z) or QBColor(x) or x //

'   //Purpose:
'   //Use to set one colour or more at a time
'   //No Initialisation required.

'   //USE THESE NAMES IN SETSYSCOLOUR (CONST_NAME, RGB(R,G,B))
Global Const COLOR_SCROLLBAR = 0
Global Const COLOR_BACKGROUND = 1
Global Const COLOR_ACTIVECAPTION = 2
Global Const COLOR_INACTIVECAPTION = 3
Global Const COLOR_MENU = 4
Global Const COLOR_WINDOW = 5
Global Const COLOR_WINDOWFRAME = 6
Global Const COLOR_MENUTEXT = 7
Global Const COLOR_WINDOWTEXT = 8
Global Const COLOR_CAPTIONTEXT = 9
Global Const COLOR_ACTIVEBORDER = 10
Global Const COLOR_INACTIVEBORDER = 11
Global Const COLOR_APPWORKSPACE = 12
Global Const COLOR_HIGHLIGHT = 13
Global Const COLOR_HIGHLIGHTTEXT = 14
Global Const COLOR_BTNFACE = 15
Global Const COLOR_BTNSHADOW = 16
Global Const COLOR_GRAYTEXT = 17
Global Const COLOR_BTNTEXT = 18
Global Const COLOR_INACTIVECAPTIONTEXT = 19
Global Const COLOR_BTNHILIGHT = 20

'   //*********************************************************************//


'   //Internal Flags//
Dim COLOURS_SAVED_OK As Integer
Dim RGBARRAY_SET_OK As Integer

'   //DLL Functions//
Declare Function GetSysColor Lib "User" (ByVal nIndex As Integer) As Long
Declare Sub SetSysColors Lib "User" (ByVal nChanges As Integer, lpSysColor As Integer, lpColorValues As Long)

'   //** Note - ALIAS names should not conflict with normal declarations//
Declare Function Beeper Lib "User" Alias "MessageBeep" (ByVal BeepType As Integer) As Integer
Declare Function GetVer Lib "Kernel" Alias "GetVersion" () As Long
Declare Function ReadFromINI Lib "Kernel" Alias "GetPrivateProfileString" (ByVal Topic As String, ByVal Keyname As String, ByVal DEFAULT As String, ByVal ReturnedString As String, ByVal maxsize As Integer, ByVal Filename As String) As Integer
Declare Function WriteToINI Lib "Kernel" Alias "WritePrivateProfileString" (ByVal Topic As String, ByVal Keyname As String, ByVal NewString As String, ByVal Filename As String) As Integer
Declare Function GetUsersWINDIR Lib "Kernel" Alias "GetWindowsDirectory" (ByVal ipbuffer As String, ByVal nSize As Integer) As Integer

'   //There are 21 System Colours in Windows 3.1//
Dim ColourText(0 To 20) As String
Dim IndexArray(0 To 20) As Integer
Dim RGBArray(0 To 20) As Long
Dim OldRGBArray(0 To 20) As Long
Dim NumChanges As Integer

Dim WINDIR As String'   //Users Windows Directory//

Sub EnumerateSchemes ()

'   //Last edited 02/07/94 [GB] //
'   //+++PUBLIC+++//

'   //Initialises Scheme(1 to ?) and i_LastScheme//
'   //Scheme() is a dynamic array of CONTROL.INI Colour Scheme names//
'   //i_LastScheme is the number of the last valid entry//

If IsWin31() = False Then
    TellBadNews'    //Windows 3.1 only//
    Exit Sub
End If

Dim sz_Buf As Variant
Dim sz_Topic As String
Dim sz_Filename As String
Dim fn As Integer'  //File Handle//
Dim pos As Integer

fn = FreeFile
sz_Topic = "[color schemes]"
If WINDIR = "" Then WINDIR = GetWINDIR()
sz_Filename = WINDIR
If Right$(sz_Filename, 1) <> "\" Then sz_Filename = sz_Filename & "\"
sz_Filename = sz_Filename & "CONTROL.INI"

'   //Find the [color schemes] topic
Open sz_Filename For Input As #fn
Do Until EOF(fn)
    Input #fn, sz_Buf
    If Len(sz_Buf) > 14 Then
        If Left$(sz_Buf, 15) = sz_Topic Then Exit Do
    End If
Loop

'   //Enumerate the keynames//
Do Until EOF(fn)
Input #fn, sz_Buf
If Len(sz_Buf) > 1 And Left$(sz_Buf, 1) = "[" Then Exit Do
pos = InStr(1, sz_Buf, "=")
If pos Then sz_Buf = Left$(sz_Buf, pos - 1)
If pos Then
    i_LastScheme = i_LastScheme + 1
    ReDim Preserve Scheme(1 To i_LastScheme)
    Scheme(i_LastScheme) = sz_Buf
End If
Loop

End Sub

Sub GetSysColoursFromINI (SchemeString As String, IniPath As String)

'   //Last edited 02/07/94 [GB] //
'   //+++PUBLIC+++//

'   //Sets the System Colours from an INI File (CONTROL PANEL style) saved Scheme setting//

If SchemeString = "" Then Exit Sub'  //Failed Test//
If IsWin31() = False Then
    TellBadNews'    //Windows 3.1 only//
    Exit Sub
End If

'   //Test if RGBArray contains valid entries//
If RGBARRAY_SET_OK = False Then Init_RGBArray'   //Also sets IndexArray//

'   //Do simple checks//
On Error GoTo EH_GSCError
If Dir$(IniPath) = "" Then Exit Sub'  //Failed Test//
If SchemeString = "" Then Exit Sub'  //Failed Test//

'   //Set up vars for DLL call//
Dim INIEntry As String
Dim i_RetVal As Integer
Dim sz_Bad As String
sz_Bad = "unknown"
Dim sz_Buf As String * 255
Dim i_SizeOfBuf As Integer
i_SizeOfBuf = 255

'   //Fetch the CSV string containing the 20 Hex numbers//
i_RetVal = ReadFromINI("color schemes", SchemeString, sz_Bad, sz_Buf, i_SizeOfBuf, IniPath)

'   //Check result//
If i_RetVal = 0 Then Exit Sub'  //Failed Test//
INIEntry = Left$(sz_Buf, i_RetVal)
If INIEntry = "unknown" Then Exit Sub'  //Failed Test//

'   //Check that there are 20 values (19 commas) in the string//
Dim i_Count As Integer
Dim AString As String
Dim pos As Integer
pos = 0
AString = INIEntry
For i_Count = 1 To 19
    pos = InStr(AString, ",")
    If pos = 0 Then Exit Sub'  //Failed Test//
    AString = Mid$(AString, pos + 1)
Next i_Count

'   //Fetch each value, and assign it to RGBArray//
Dim HexString As String
pos = 0
AString = INIEntry

For i_Count = 0 To 19
    pos = InStr(AString, ",")
    HexString = Left$(AString, pos - 1)
    AString = Mid$(AString, pos + 1)
    RGBArray(i_Count) = Hex2RGB(HexString)
Next i_Count
'   //Fetch 20th Value//
RGBArray(20) = Hex2RGB(AString)

'   //Re-order IndexArray to point to the CONTROL.INI order//
ReMapIndexArray2ControlPanel

'   //Do the deed//
NumChanges = 21'    //Change all the colours in 1 go//
SetSysColors NumChanges, IndexArray(0), RGBArray(0)

'   //Come here if an error//
EH_GSCError:
'   //Reset to ordinal values//
Init_IndexArray

End Sub

Function GetWINDIR () As String

'   //Last Edited 02/07/94 [GB] //
'   //+++PRIVATE+++//

Dim sz_Buf As String * 255
Dim i_RetVal As Integer
Dim i_SizeOfBuf As Integer
i_SizeOfBuf = 255

'   //Use alias in case GetWindowsDirectory has been declared already//
i_RetVal = GetUsersWINDIR(sz_Buf, i_SizeOfBuf)

If i_RetVal = 0 Then '  //Failed Test//
    MsgBox "Could not locate Windows Directory", 16, "GetWINDIR Fatal Error"
    End
End If
GetWINDIR = Left$(sz_Buf, i_RetVal)

End Function

Function H2D (Char As String) As Integer

'   //Last Edited 02/07/94 [GB] //
'   //+++PRIVATE+++//

'   //Converts a single Hex caracter into it's decimal equivalent//

Select Case Char
    Case "0" To "9"
        H2D = Val(Char)
    Case "A" To "F"
        H2D = Asc(Char) - 55
    Case Else
        Exit Function'  //Failed Test//
End Select

End Function

Function Hex2Long (HexString As String) As Long

'   //Last Edited 02/07/94 [GB] //
'   //+++PUBLIC+++//

'   //Converts a valid Hex$ into it's corresponding decimal value//
'   //USES: IsHexDigit() //
'   //** Do NOT use this for converting RGB Hex strings **//

Hex2Long = 0'   //Default Value//

If HexString = "" Then Exit Function'  //Failed Test//
Dim LENH As Integer
LENH = Len(HexString)
If LENH > 8 Then Exit Function'  //Failed Test//

'   //Passed checks OK, so...//
HexString = UCase$(HexString)
Dim i_Count As Integer
Dim l_Temp As Long
Dim Char As String
Dim Dec As Integer

'   //Hex number is converted in one step//
'   //Count from the last char to the first//
For i_Count = LENH To 1 Step -1
    Char = Mid$(HexString, i_Count, 1)
    If Not IsHexDigit(Char) Then Exit Function'  //Failed Test//
    Select Case Char
        Case "0" To "9"
            Dec = Val(Char)
        Case "A" To "F"
            Dec = Asc(Char) - 55
        Case Else
            Exit Function'  //Failed Test//
    End Select
    l_Temp = l_Temp + (Dec * (16 ^ (LENH - i_Count)))
Next i_Count

Hex2Long = l_Temp

End Function

Function Hex2RGB (HexString As String) As Long

'   //Last Edited 02/07/94 [GB] //
'   //+++PRIVATE+++//

'   //Converts a valid [BBGGRR] Hex$ into it's corresponding decimal value//
'   //Used to decipher the CONTROL.INI values//
'   //USES: IsHexDigit() //

Hex2RGB = 0'   //Default Value//

If HexString = "" Then Exit Function'  //Failed Test//
If HexString = "0" Then Exit Function'  //Failed Test//

Dim LENH As Integer
LENH = Len(HexString)
If LENH > 6 Then Exit Function'  //Failed Test//

'   //Passed checks OK, so...//
HexString = UCase$(HexString)
Dim i_Count As Integer
Dim l_Temp As Long
Dim Char As String
Dim Dec As Integer

'   //Check that all are Valid Hex Digits//
For i_Count = 1 To LENH
    Char = Mid$(HexString, i_Count, 1)
    If Not IsHexDigit(Char) Then Exit Function'  //Failed Test//
Next i_Count

'   //Hex string could be 1,2,4,6 digits long//
'   //1 digit (0) has been dealt with//
'   //Order is BGR//

'   //Make it a RGB string//
Dim AString As String * 6
AString = "000000"

RSet AString = HexString

Dim iRED As Integer
Dim iGREEN As Integer
Dim iBLUE As Integer

'   //Microsoft store it as BBGGRR!//
'   //Get Blue//
iBLUE = 16 * H2D(Mid$(AString, 1, 1)) + H2D(Mid$(AString, 2, 1))
'   //Get Green//
iGREEN = 16 * H2D(Mid$(AString, 3, 1)) + H2D(Mid$(AString, 4, 1))
'   //Get Red//
iRED = 16 * H2D(Mid$(AString, 5, 1)) + H2D(Mid$(AString, 6, 1))

Hex2RGB = RGB(iRED, iGREEN, iBLUE)

End Function

Sub Init_ColourText ()

'   //Last edited 02/07/94 [GB] //
'   //+++PRIVATE+++//

'   //These strings are used in the INI-File routines//
'   //It is called by routines (Set/Write)Colours(To/From)INI //

ColourText(0) = "COLOR_BACKGROUND"
ColourText(1) = "COLOR_APPWORKSPACE"
ColourText(2) = "COLOR_WINDOW"
ColourText(3) = "COLOR_WINDOWTEXT"
ColourText(4) = "COLOR_MENU"
ColourText(5) = "COLOR_MENUTEXT"
ColourText(6) = "COLOR_ACTIVECAPTION"
ColourText(7) = "COLOR_INACTIVECAPTION"
ColourText(8) = "COLOR_CAPTIONTEXT"
ColourText(9) = "COLOR_HIGHLIGHT"
ColourText(10) = "COLOR_INACTIVECAPTIONTEXT"
ColourText(11) = "COLOR_ACTIVEBORDER"
ColourText(12) = "COLOR_INACTIVEBORDER"
ColourText(13) = "COLOR_WINDOWFRAME"
ColourText(14) = "COLOR_SCROLLBAR"
ColourText(15) = "COLOR_BTNFACE"
ColourText(16) = "COLOR_BTNSHADOW"
ColourText(17) = "COLOR_HIGHLIGHTTEXT"
ColourText(18) = "COLOR_BTNTEXT"
ColourText(19) = "COLOR_BTNHILIGHT"
ColourText(20) = "COLOR_GRAYTEXT"

End Sub

Sub Init_IndexArray ()

'   //Last edited 02/07/94 [GB] //
'   //+++PRIVATE+++//

'   //This routine is called from other routines//
'   //See - Sub ReMapIndexArrayToControlPanel() //

Dim i_Count As Integer
For i_Count = 0 To 20
'   //Initialise reference array//
    IndexArray(i_Count) = i_Count
Next i_Count
End Sub

Sub Init_RGBArray ()

'   //Last edited 02/07/94 [GB] //
'   //+++PRIVATE+++//

'   //This routine is called by other routines//
'   //**Note the variable RGBARRAY_SET_OK //

'   //It sets RGBArray - essential before SetSysColour!//
'   //It can also sets IndexArray - this is necessary for other routines//

If IndexArray(1) <> 1 Then Init_IndexArray

Dim i_Count As Integer
For i_Count = 0 To 20
'   //Get the User's System Colour values//
    RGBArray(i_Count) = GetSysColor(i_Count)
Next i_Count

RGBARRAY_SET_OK = True

End Sub

Function IsHexDigit (Char As String) As Integer

'   //Last edited 02/07/94 [GB] //
'   //+++PRIVATE+++//

IsHexDigit = False'   //Assume guilt, look for innocence//
If Char = "" Then Exit Function'  //Failed Test//

Dim Digits As String
Digits = "0123456789ABCDEF"
Char = UCase$(Left$(Char, 1))

If InStr(Digits, Char) <> 0 Then IsHexDigit = True

End Function

Function IsWin31 () As Integer

'   //Last Edited 02/07/94 [GB] //
'   //+++PRIVATE+++//

'   //The SYSCOLOR functions all assume a 21-Colour scheme//
'   //Windows 3.0 only has 19 colours//

IsWin31 = False
'   //First, a quick & Dirty test for Windows V3.1//
If GetVer() = 101976579 Then
    IsWin31 = True
    Exit Function
End If

'   //Now check properly...//
Dim check As Long
Dim major As String
Dim minor As String
Dim winver As String
Dim M As String
'   {Check that the user is running Windows V3.1 or above}
check& = GetVer()
major$ = Format$(check& And &HFF)
minor$ = Format$((check& And &HF00) / 256)
winver$ = major$ + "." + minor$

If Val(winver$) >= 3.1 Then IsWin31 = True


End Function

Sub ReMapIndexArray2ControlPanel ()

'   //Last edited 02/07/94 [GB] //
'   //+++PRIVATE+++//

'   //INPUT: IndexArray in Value order//
'   //ie IndexArray(0)=0
'   //   IndexArray(1)=1

'   //OUTPUT: IndexArray according to CONTROL.INI//
'   //ie IndexArray(0)=1
'   //IndexArray(1)=12

If IsWin31() = False Then
    TellBadNews'    //Windows 3.1 only//
    Exit Sub
End If

'   //This is the order the CONTROL.INI entries are stored in//
IndexArray(0) = COLOR_BACKGROUND
IndexArray(1) = COLOR_APPWORKSPACE
IndexArray(2) = COLOR_WINDOW
IndexArray(3) = COLOR_WINDOWTEXT
IndexArray(4) = COLOR_MENU
IndexArray(5) = COLOR_MENUTEXT
IndexArray(6) = COLOR_ACTIVECAPTION
IndexArray(7) = COLOR_INACTIVECAPTION
IndexArray(8) = COLOR_CAPTIONTEXT
IndexArray(9) = COLOR_ACTIVEBORDER
IndexArray(10) = COLOR_INACTIVEBORDER
IndexArray(11) = COLOR_WINDOWFRAME
IndexArray(12) = COLOR_SCROLLBAR
IndexArray(13) = COLOR_BTNFACE
IndexArray(14) = COLOR_BTNSHADOW
IndexArray(15) = COLOR_BTNTEXT
IndexArray(16) = COLOR_GRAYTEXT
IndexArray(17) = COLOR_HIGHLIGHT
IndexArray(18) = COLOR_HIGHLIGHTTEXT
IndexArray(19) = COLOR_INACTIVECAPTIONTEXT
IndexArray(20) = COLOR_BTNHILIGHT

End Sub

Sub RestoreSysColours ()

'   //Last edited 02/07/94 [GB] //
'   //+++PUBLIC+++//

'   //Restores system colours to that saved by SaveSysColours

If IsWin31() = False Then
    TellBadNews'    //Windows 3.1 only//
    Exit Sub
End If

'   //Test if OldRGBArray is valid//
If COLOURS_SAVED_OK = False Then SaveSysColours
'    //Sets OldRGBArray and IndexArray//


Dim i_Count As Integer
'   //Pump values into the array//
For i_Count = 0 To 20
'   //Change the appropriate element in the array//
    RGBArray(i_Count) = OldRGBArray(i_Count)
Next i_Count

'   //Do the deed//
NumChanges = 21'    //Change all the colours in 1 go//
SetSysColors NumChanges, IndexArray(0), RGBArray(0)

End Sub

Sub SaveSysColours ()

'   //Last edited 02/07/94 [GB] //
'   //+++PUBLIC+++//

'   //This routine stores the User's System Colours//
'   //Call it to take a snapshot (to be restored by RestoreSysColours) //

'   //**Sets RGBArray and OldRGBArray//
'   //**Note the Variables COLOURS_SAVED_OK and RGBARRAY_SET_OK //

If IsWin31() = False Then
    TellBadNews'    //Windows 3.1 only//
    Exit Sub
End If

If IndexArray(1) <> 1 Then Init_IndexArray

Dim i_Count As Integer
For i_Count = 0 To 20
'   //Get a User's System Colour value//
    OldRGBArray(i_Count) = GetSysColor(i_Count)

'   //Copy to the working set//
    RGBArray(i_Count) = OldRGBArray(i_Count)
Next i_Count

COLOURS_SAVED_OK = True
RGBARRAY_SET_OK = True
End Sub

Sub SetColourSchemeFromControlPanel (SchemeString As String)

'   //Last edited 02/07/94 [GB] //
'   //+++PUBLIC+++//

'   //Sets the System Colours from a CONTROL PANEL saved Scheme setting//
If IsWin31() = False Then
    TellBadNews'    //Windows 3.1 only//
    Exit Sub
End If

If SchemeString = "" Then Exit Sub'  //Failed Test//

'   //Test if RGBArray contains valid entries//
If RGBARRAY_SET_OK = False Then Init_RGBArray'   //Also sets IndexArray//

Dim IniPath As String
Dim USERWINDIR As String

'   //Get INI path//
USERWINDIR = GetWINDIR()
If Right$(USERWINDIR, 1) <> "\" Then USERWINDIR = USERWINDIR & "\"
IniPath = USERWINDIR & "CONTROL.INI"

On Error GoTo EH_SCSCP
If Dir$(IniPath) = "" Then Exit Sub'  //Failed Test//

'   //Set up vars for DLL call//
Dim INIEntry As String
Dim i_RetVal As Integer
Dim sz_Bad As String
sz_Bad = "unknown"
Dim sz_Buf As String * 255
Dim i_SizeOfBuf As Integer
i_SizeOfBuf = 255

'   //Fetch the CSV string containing the 20 Hex numbers//
i_RetVal = ReadFromINI("color schemes", SchemeString, sz_Bad, sz_Buf, i_SizeOfBuf, IniPath)

'   //Test for bad return value//
If i_RetVal = 0 Then Exit Sub'  //Failed Test//
INIEntry = Left$(sz_Buf, i_RetVal)
If INIEntry = "unknown" Then Exit Sub'  //Failed Test//

'   //Check that there are 20 values (19 commas) in the string//
Dim i_Count As Integer
Dim AString As String
Dim pos As Integer
pos = 0
AString = INIEntry
For i_Count = 1 To 19
    pos = InStr(AString, ",")
    If pos = 0 Then Exit Sub'  //Failed Test//
    AString = Mid$(AString, pos + 1)
Next i_Count

'   //Fetch each value, and assign it to RGBArray//
Dim HexString As String
pos = 0
AString = INIEntry

For i_Count = 0 To 19
    pos = InStr(AString, ",")
    HexString = Left$(AString, pos - 1)
    AString = Mid$(AString, pos + 1)
    RGBArray(i_Count) = Hex2RGB(HexString)
Next i_Count
'   //Fetch 20th Value//
RGBArray(20) = Hex2RGB(AString)

'   //Re-order IndexArray to point to the CONTOL.INI order//
ReMapIndexArray2ControlPanel

'   //Do the deed//
NumChanges = 21'    //Change all the colours in 1 go//
SetSysColors NumChanges, IndexArray(0), RGBArray(0)

'   //Come here on error//
EH_SCSCP:
'   //Reset to ordinal values//
Init_IndexArray

End Sub

Sub SetDefaultColourSchemeFromControlPanel ()

'   //Last edited 02/07/94 [GB] //
'   //+++PUBLIC+++//

'   //Sets the System Colours from CONTROL.INI setting//
If IsWin31() = False Then
    TellBadNews'    //Windows 3.1 only//
    Exit Sub
End If

'   //Test if RGBArray contains valid entries//
If RGBARRAY_SET_OK = False Then Init_RGBArray'   //Also sets IndexArray//

'   //Get Users CONTROL.INI Path//
Dim IniPath As String
Dim USERWINDIR As String
USERWINDIR = GetWINDIR()
If Right$(USERWINDIR, 1) <> "\" Then USERWINDIR = USERWINDIR & "\"
IniPath = USERWINDIR & "CONTROL.INI"

On Error GoTo EH_SDCSFCP
If Dir$(IniPath) = "" Then Exit Sub'  //Failed Test//

'   //Setup DLL ReadFromINI call//
Dim i_RetVal As Integer
Dim sz_Bad As String
sz_Bad = "unknown"
Dim sz_Buf As String * 255
Dim i_SizeOfBuf As Integer
i_SizeOfBuf = 255


'   //Fetch the current System Colour name//
Dim DefaultKey As String
i_RetVal = ReadFromINI("current", "color schemes", sz_Bad, sz_Buf, i_SizeOfBuf, IniPath)

'   //Test for valid return value//
If i_RetVal = 0 Then Exit Sub'  //Failed Test//
DefaultKey = Left$(sz_Buf, i_RetVal)
If DefaultKey = "unknown" Then Exit Sub'  //Failed Test//

'   //Fetch the CSV string containing the 20 Hex numbers//
i_RetVal = ReadFromINI("color schemes", DefaultKey, sz_Bad, sz_Buf, i_SizeOfBuf, IniPath)
'   //Test for valid return value//
If i_RetVal = 0 Then Exit Sub'  //Failed Test//

Dim INIEntry As String
INIEntry = Left$(sz_Buf, i_RetVal)
If INIEntry = "unknown" Then Exit Sub'  //Failed Test//

'   //Check that there are 20 values (19 commas) in the string//
Dim i_Count As Integer
Dim AString As String
Dim pos As Integer
pos = 0
AString = INIEntry
For i_Count = 1 To 19
    pos = InStr(AString, ",")
    If pos = 0 Then Exit Sub'   //Failed Test//
    AString = Mid$(AString, pos + 1)
Next i_Count

'   //Fetch each value, and assign it to RGBArray//
'   //** Note - Hex2RGB decodes the BBGGRR hex$ used by MS //
Dim HexString As String
pos = 0
AString = INIEntry

For i_Count = 0 To 19
    pos = InStr(AString, ",")
    HexString = Left$(AString, pos - 1)
    AString = Mid$(AString, pos + 1)
    RGBArray(i_Count) = Hex2RGB(HexString)
Next i_Count
'   //Fetch 20th Value//
RGBArray(20) = Hex2RGB(AString)


'   //Re-order IndexArray to point to the CONTROL.INI order//
ReMapIndexArray2ControlPanel

'   //Do the deed//
NumChanges = 21'    //Change all the colours in 1 go//
SetSysColors NumChanges, IndexArray(0), RGBArray(0)

'   //Come here if there's an error//
EH_SDCSFCP:
'   //Reset to ordinal values//
Init_IndexArray

End Sub

Sub SetSysColour (Element As Integer, RGBValue As Long)

'   //Last edited 02/07/94 [GB] //
'   //+++PUBLIC+++//

'   //Element is one of the COLOR_ constants in the
'   //Declarations() section of this module//

'   //RGBValue can be RGB(x,y,z) or OPTCOLOR(colour) or QBColor(x)//

'   //**Note -You may want to call SaveSysColours first so that you can use
'   //the routine RestoreSysColours to return the User to normal, later//

If IsWin31() = False Then
    TellBadNews'    //Windows 3.1 only//
    Exit Sub
End If
'   //Test if RGBArray contains valid entries//
If RGBARRAY_SET_OK = False Then Init_RGBArray'   //Also sets IndexArray//


'   //Change the appropriate element in the array//
RGBArray(Element) = RGBValue

NumChanges = 21'    //Change all the colours in 1 go//
'   //Do the deed//
SetSysColors NumChanges, IndexArray(0), RGBArray(0)

'   //NB The changed colour will persist in subsequent calls
'   //to this routine until RestoreSysColours() is called//
End Sub

Sub TellBadNews ()

'   //Last Edited 02/07/94 [GB] //
'   //+++PRIVATE+++//

Dim msg As String
Dim answer As Integer

answer = Beeper(16)'   //Issue an MCI Fatal Error sound//
msg = "You appear to be running Microsoft" & Chr$(10)
msg = msg & "Windows(tm) Version 3.0 or less. " & Chr$(10)
msg = msg & Chr$(10)
msg = msg & "SYSCOLOR functions are designed to support" & Chr$(10)
msg = msg & " only the 21-colour scheme of Windows 3.1." & Chr$(10)
msg = msg & Chr$(10)
msg = msg & "Would you like to Exit back to Windows now?"
answer = MsgBox(msg, 4096 + 48 + 4, "SYSCOLOR Fatal Error")
If answer = 6 Then End
End Sub

Sub WriteSysColoursToINI (SchemeString As String, IniPath As String)

'   //Last edited 02/07/94 [GB] //
'   //+++PUBLIC+++//

'   //This routine stores the User's 20 Windows System colours in INIPathName//
'   //Nothing needs to be initialised first//

'   //** The routine GetColoursFromINI will fetch the settings into the system//

'   //** Note - You may want to call SaveSysColours first so that you can use
'   //the routine RestoreSysColours to return the User to normal, later//

If IsWin31() = False Then
    TellBadNews'    //Windows 3.1 only//
    Exit Sub
End If
'   //Obvious checks, first//
If Dir$(IniPath) = "" Then Exit Sub
If SchemeString = "" Then Exit Sub

Dim i_Count As Integer
Dim RGBString As String
Dim NumString As String
Dim sz_BigString As String

'   //Save as per CONTROL.INI style//
ReMapIndexArray2ControlPanel

For i_Count = 0 To 19
'   //Get a User's System Colour value, and//
'   //Encode it into a Decimal string//
    RGBString = Hex$(GetSysColor(IndexArray(i_Count)))
    sz_BigString = sz_BigString & RGBString & ","
Next i_Count
'   //Last value not followed by a comma//
RGBString = Hex$(GetSysColor(IndexArray(20)))
sz_BigString = sz_BigString & RGBString

Dim Topic As String
Dim Keyname As String
Dim i_RetVal As Integer
Topic = "color schemes"
Keyname = SchemeString

'   //Write the new setting//
i_RetVal = WriteToINI(Topic, Keyname, sz_BigString, IniPath)
'   //Re-Map for Save/Restore//
Init_IndexArray

End Sub